home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / sterm.stk < prev    next >
Encoding:
Text File  |  1996-06-25  |  3.5 KB  |  101 lines
  1. ;;;;
  2. ;;;; s t e r m  . s t k  --  A simple terminal emulator written in Scheme
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;;
  15. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  16. ;;;;    Creation date:  2-Oct-1995 22:57
  17. ;;;; Last file update: 25-Jun-1996 23:31
  18.  
  19. (require "process")
  20.  
  21. (define (sterm)
  22.   (define prompt-color   "red")
  23.   (define output-color   "blue")
  24.   (define update-counter 0)
  25.  
  26.   (define (close-sterm w)
  27.     (w 'insert "end" "*** EOF ***" "list-prompt")
  28.     ;; Set state to "disabled" (or delete the <Return> binding). Not doing so,
  29.     ;; stops the interpreter. The bugs seems to be in Tk event loop, since 
  30.     ;; similar code works without event.
  31.     (tk-set! w :state "disabled"))
  32.  
  33.   (define (insert-prompt w file)
  34.     (let Loop ()
  35.       (when (char-ready? file)
  36.     (let ((c (read-char file)))
  37.       (cond 
  38.         ((eof-object? c)  (when-port-readable file #f)
  39.                   (close-sterm w))
  40.         (ELSE             ;; Insert this char and try to read another one
  41.                           (w 'insert "end" (string c) "list-prompt")
  42.                   (Loop))))))
  43.     ;; Add a mark to the current position
  44.     (w 'mark 'set "start_expr" "end-1c")
  45.     (w 'mark 'gravity "start_expr" "left")
  46.     (w 'see "end"))
  47.  
  48.   (define (insert-line w line)
  49.     (w 'insert "insert" line "list-output" "\n" "")
  50.     (w 'see "end")
  51.     ;; Force a redisplay when we have a bunch of lines to animate screen
  52.     (if (= update-counter 5) 
  53.     (begin (update 'idle) (set! update-counter 0))
  54.     (set! update-counter (+ update-counter 1))))
  55.  
  56.   (define (read-a-line w file)
  57.     (let Loop ()
  58.       (if (char-ready? file)
  59.       (let ((l (read-line file)))
  60.         (if (eof-object? l)
  61.         (when-port-readable file #f)
  62.         (begin
  63.           (insert-line w l)
  64.           (Loop)))))))
  65.  
  66.   (define (make-term name closure . tk-args)
  67.     (let ((w (apply Tk:text (format #f "~A.t" name) tk-args))
  68.       (s (scrollbar (format #f "~A.s" name) :orient "vert")))
  69.  
  70.       (pack w :expand #t :fill "both" :side "left")
  71.       (pack s :expand #f :fill "y" :side "right")
  72.  
  73.       ;; Associate bindings to the scrollbar
  74.       (tk-set! w :yscroll (lambda l (apply s 'set l)))
  75.       (tk-set! s :command (lambda l (apply w 'yview l)))
  76.          
  77.       (bind w "<Return>" closure)
  78.       (w 'tag 'configure "list-prompt" :foreground prompt-color)
  79.       (w 'tag 'configure "list-output" :foreground output-color)
  80.       w))
  81.   
  82.   (let* ((sh  (or (getenv "SHELL") "/bin/sh"))
  83.      (p   (run-process sh "-i" :input :pipe :output :pipe :error :pipe))
  84.      (in  (process-input  p))
  85.      (out (process-output p))
  86.      (err (process-error  p))
  87.      (top (toplevel (gensym ".term")))
  88.      (t   #f)     ;; Will be set later since it needs C defined below
  89.      (C   (lambda () 
  90.         (let ((txt (t 'get "start_expr" "insert")))
  91.           (display txt in) (newline in) (flush in)
  92.           'continue))))
  93.     (set! t (make-term  (widget-name top) C :font "fixed" :setgrid #t))
  94.     (pack t :expand #t :fill "both")
  95.  
  96.     ;; Create handlers
  97.     (when-port-readable err (lambda () (insert-prompt t err)))
  98.     (when-port-readable out (lambda () (read-a-line t out)))))
  99.  
  100. (provide "sterm")
  101.